Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/enumfont/enumfont.frm

Visual Basic Form | 1995-09-06 | 5.5 KB | 157 lines

VERSION 2.00
Begin Form form_enumfont
   Caption         =   "EnumFonts Demo"
   ClientHeight    =   3000
   ClientLeft      =   870
   ClientTop       =   2730
   ClientWidth     =   6945
   Height          =   3690
   Icon            =   0
   Left            =   810
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   ScaleHeight     =   3000
   ScaleWidth      =   6945
   Top             =   2100
   Width           =   7065
   Begin ListBox lst_fonts
      Height          =   2175
      Left            =   2520
      TabIndex        =   3
      Top             =   600
      Width           =   4095
   End
   Begin ListBox Lst_Faces
      Height          =   2175
      Left            =   360
      TabIndex        =   1
      Top             =   600
      Width           =   1935
   End
   Begin Label Label2
      Alignment       =   2  'Center
      Caption         =   "Fonts"
      Height          =   255
      Left            =   2520
      TabIndex        =   2
      Top             =   240
      Width           =   4095
   End
   Begin Label Label1
      Alignment       =   2  'Center
      Caption         =   "Typefaces"
      Height          =   255
      Left            =   360
      TabIndex        =   0
      Top             =   240
      Width           =   1935
   End
   Begin Menu menu_file
      Caption         =   "&File"
      Begin Menu menu_file_exit
         Caption         =   "&Exit"
      End
   End
   Begin Menu menu_help
      Caption         =   "&Help"
      Begin Menu menu_help_about
         Caption         =   "&About"
      End
   End
' Copyright (C) Telelink Systems 1991
' Phone:  [phone]
' Fax:    [phone]
' Cserve: 70523,2574
Sub cmd_OK_Click ()
   Unload form_Enumfont
End Sub
Sub Form_Load ()
   '-- Find how many typefaces are there
   nFaceCnt% = VBEnumFonts(Printer.hDC, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, 0)
   '-- Prepare an array for the typefaces
   ReDim lfFace(nFaceCnt% - 1) As LOGFONT
   '-- Fill the array -- one entry for each typeface
   dummy% = VBEnumFonts(Printer.hDC, ByVal 0&, lfFace(0), ByVal 0&, ByVal 0&, nFaceCnt%)
   '-- Add the typeface names to the list box
   For Face% = 0 To nFaceCnt% - 1
      '-- retrieve face name
      st$ = lfFace(Face%).lfFaceName
      '-- trim the fixed string into a variable string
      lst_faces.AddItem Left$(st$, InStr(st$, Chr$(0)) - 1)
   Next Face%
   '-- point to first typeface -- this will trigger a click event
   '   for the lst_faces object
   lst_faces.listindex = 0
End Sub
Sub Form_Resize ()
   lst_faces.SetFocus
End Sub
Sub Lst_Faces_Click ()
   If lst_faces.listindex >= 0 Then
      '-- clear font list
      Do While lst_Fonts.listcount > 0
         lst_Fonts.RemoveItem 0
      Loop

      '-- find how many fonts in this typeface
      FaceName$ = lst_faces.list(lst_faces.listindex)
      nFontcnt% = VBEnumFonts(Printer.hDC, FaceName$, ByVal 0&, ByVal 0&, ByVal 0&, 0)

      '-- Prepare 3 arrays to receive font information
      ReDim lfFont(nFontcnt% - 1) As LOGFONT
      ReDim tmFont(nFontcnt% - 1) As TEXTMETRIC
      ReDim nTypeFont(nFontcnt% - 1) As Integer
      '-- change mapping mode to pixels, fill arrays, and restore mapping mode
      oldMapMode% = SetMapMode(Printer.hDC, MM_TEXT)
      dummy% = VBEnumFonts(Printer.hDC, FaceName$, lfFont(0), tmFont(0), nTypeFont(0), nFontcnt%)
      dummy% = SetMapMode(Printer.hDC, oldMapMode%)

      '-- find pixels per inch for printer
      pixels_per_inch% = GetDeviceCaps(Printer.hDC, LOGPIXELSY)
      '-- reflect the information into the font list
      For font% = 0 To nFontcnt% - 1
         '-- Font size, in points, is twips divided by 20
         st$ = Str$(tmFont(font%).tmHeight * 72 / pixels_per_inch%) + " Pts"
         '-- add italic/bold/etc
         If Asc(tmFont(font%).tmItalic) Then st$ = st$ + " Italic"
         If Asc(tmFont(font%).tmUnderlined) Then st$ = st$ + " Underline"
         If Asc(tmFont(font%).tmStruckout) Then st$ = st$ + " Strikeout"
         If tmFont(font%).tmWeight > 550 Then st$ = st$ + " Bold"
         '-- font pitch
         Select Case (Asc(tmFont(font%).tmPitchAndFamily) And &H1)
           Case 0:   st$ = st$ + " Fixed"
           Case 1: st$ = st$ + " Var"
         End Select
         '-- What kind of font?
         Select Case (Asc(tmFont(font%).tmPitchAndFamily) And &HF0)
           Case FF_DECORATIVE: st$ = st$ + ", Decorative"
           Case FF_DONTCARE: st$ = st$ + ", Dontcare"
           Case FF_MODERN: st$ = st$ + ", Modern"
           Case FF_ROMAN: st$ = st$ + ", Roman"
           Case FF_SCRIPT: st$ = st$ + ", Script"
           Case FF_SWISS: st$ = st$ + ", Swiss"
           Case Else: st$ = st$ + ", FF_Error"
         End Select
         '-- font type
         Select Case nTypeFont(font%) And &H3
            Case 0: st$ = st$ + " GDI Stroke"
            Case 1: st$ = st$ + " GDI Raster"
            Case 2: st$ = st$ + " Device Stroke"
            Case 3: st$ = st$ + " Device Raster"
         End Select
         lst_Fonts.AddItem st$
      Next font%
   End If
End Sub
Sub menu_file_exit_Click ()
  End
End Sub
Sub menu_help_about_Click ()
  msg1$ = "Copyright (C) Telelink Systems 1991"
  msg2$ = "Phone:  [phone]"
  msg3$ = "Fax:    [phone]"
  msg4$ = "Cserve:  70523,2574"
  crlf$ = Chr$(10) + Chr$(13)
  MsgBox msg1$ + crlf$ + crlf$ + msg2$ + crlf$ + msg3$ + crlf$ + msg4$
End Sub